home *** CD-ROM | disk | FTP | other *** search
/ Gold Medal Software 3 / Gold Medal Software - Volume 3 (Gold Medal) (1994).iso / bbsutils / bgfax120.arj / SOURCE.ARJ / MAKEFAX.PAS < prev    next >
Pascal/Delphi Source File  |  1994-03-24  |  10KB  |  391 lines
  1. program
  2.   test;
  3.  
  4. {$R+}
  5. uses
  6.   dos, crt;
  7.  
  8. {$i faxatree.pas}
  9. const
  10.   base2 : array[1..13] of word =
  11.     (1, 2, 4, 8, 16, 32, 64, 128, 256, 512, 1024, 2048, 4096);
  12.   base2r : array[1..8] of byte = (128, 64, 32, 16, 8, 4, 2, 1);
  13.   maxoutbuf = 8192;
  14.   maxfontbuf = 8192;
  15.  
  16. type
  17.   pcxrec = record
  18.     zsoft    : byte;
  19.     version  : byte;
  20.     encoding : byte;
  21.     bitpix   : byte;
  22.     dimens   : array[1..4] of word;
  23.     hres     : word;
  24.     vres     : word;
  25.     palette  : array[1..48] of byte;
  26.     reserved : byte;
  27.     planes   : byte;
  28.     byteline : word;
  29.     paltype  : word;
  30.     xssize   : word;
  31.     yssize   : word;
  32.     filler   : array[1..54] of byte;
  33.   end;
  34.   zfaxhead = record
  35.     header   : array[1..5] of char;
  36.     offset   : byte;
  37.     version  : word;
  38.     reserved : word;
  39.     pgwidth  : word;
  40.     pgcount  : word;
  41.     coding   : word;
  42.   end;
  43.   fontsettype = array[0..maxfontbuf] of byte;
  44.  
  45. var
  46.   io, v, j, r, c, lines, p, bytesread, pcxbufp, outbufbit, outbufbyte : word;
  47.   tf : text;
  48.   pcxfile, outfile, fontfile : file;
  49.   pcx : pcxrec;
  50.   zfax : zfaxhead;
  51.   pcxbuf : array[1..8192] of byte;
  52.   outbuf : array[1..maxoutbuf] of byte;
  53.   imagebuf : array[1..216] of byte;
  54.   fontptr : array[0..255] of word;
  55.   regs : registers;
  56.   endofpage : boolean;
  57.   fontset : ^fontsettype;
  58.   sarray : array[1..108] of byte;
  59.   slen : byte;
  60.   tlines : word;
  61.   fn, fopen : string[79];
  62.  
  63. procedure fatal(s : string);
  64. begin
  65.   writeln;
  66.   writeln(#7'Fatal Error: '+s);
  67.   halt(1);
  68. end;
  69.  
  70. procedure loadingblock;
  71. begin
  72.   if tlines = 65535 then begin {display only on PCX conversion}
  73.     clreol;
  74.     write(#13'[', filepos(pcxfile) div 1024, 'K]  Memory [', memavail div 1024,
  75.       'K]  Scan Lines [', lines, ']'#13);
  76.   end;
  77. end;
  78.  
  79. procedure putoutbit(b : byte);
  80. var
  81.   zz : word;
  82. begin
  83.   inc(outbufbit);
  84.   if outbufbit > 8 then begin
  85.     inc(outbufbyte);
  86.     outbufbit := 1;
  87.     if outbufbyte > maxoutbuf then begin
  88.       blockwrite(outfile, outbuf, sizeof(outbuf), zz);
  89.       fillchar(outbuf, sizeof(outbuf), #0);
  90.       outbufbyte := 1;
  91.     end;
  92.   end;
  93.   if b = 1 then
  94.     outbuf[outbufbyte] := outbuf[outbufbyte] xor base2[outbufbit]
  95. end;
  96.  
  97. procedure addtostream(token : word; color : boolean);
  98. var
  99.   i : byte;
  100. begin
  101.   if color then begin
  102.     for i := 1 to whitea[token][0] do begin
  103.       if (whitea[token][1] and base2[i]) > 0 then
  104.         putoutbit(1)
  105.       else
  106.         putoutbit(0);
  107.     end;
  108.   end else begin
  109.     for i := 1 to blacka[token][0] do begin
  110.       if (blacka[token][1] and base2[i]) > 0 then
  111.         putoutbit(1)
  112.       else
  113.         putoutbit(0);
  114.     end;
  115.   end;
  116. end;
  117.  
  118. procedure insertlines(num : word);
  119. var
  120.   i : word;
  121.   col : boolean;
  122. begin
  123.    inc(lines, num);
  124.    for i := 1 to num do begin
  125.      addtostream(90, true); { white 1728 makeup code }
  126.      addtostream(0, true); { white 0 final code }
  127.      while outbufbit <> 4 do
  128.         putoutbit(0); { FILL so that EOL's are byte aligned }
  129.      addtostream(104, true); { eol token }
  130.    end;
  131. end;
  132.  
  133. procedure makeendofpage(endoffax : boolean);
  134. var
  135.   i, j, c : byte;
  136. begin
  137.   if tlines < 65535 then
  138.     insertlines(1068-lines);
  139.   c := 7;
  140.   if endoffax then
  141.     c := 6;
  142.   inc(zfax.pgcount);
  143.   for i := 1 to c do begin
  144.     for j := 1 to 11 do
  145.       putoutbit(0);
  146.     putoutbit(1);
  147.   end;
  148.   lines := 0;
  149. end;
  150.  
  151. function readbyte : byte;
  152. begin
  153.   if pcxbufp >= bytesread then begin
  154.     if endofpage then begin
  155.       makeendofpage(true);
  156.       blockwrite(outfile, outbuf, outbufbyte, io);
  157.       write('Updating page count...');
  158.       close(outfile);
  159.       reset(outfile, 1); { update page count }
  160.       blockwrite(outfile, zfax, sizeof(zfax));
  161.       close(outfile);
  162.       close(pcxfile);
  163.       writeln('Conversion complete.');
  164.       halt;
  165.     end;
  166.     blockread(pcxfile, pcxbuf, sizeof(pcxbuf), bytesread);
  167.     loadingblock;
  168.     if filepos(pcxfile) = filesize(pcxfile) then
  169.       endofpage := true;
  170.     pcxbufp := 1;
  171.   end else
  172.     inc(pcxbufp);
  173.   readbyte := pcxbuf[pcxbufp];
  174. end;
  175.  
  176.  
  177. procedure countmh(count : word; var totalcount : word; var color : boolean; endofline : boolean);
  178. begin
  179.   inc(totalcount, count);
  180.   if (endofline) and (totalcount <> 1728) then begin
  181.     inc(count, 1728-totalcount);
  182.     totalcount := 1728;
  183.   end;
  184.   if count > 63 then begin
  185.     addtostream((count div 64)+63, color); {makeup code}
  186.     addtostream(count mod 64, color); {final code}
  187.   end else
  188.     addtostream(count, color);
  189.   if endofline then begin
  190.     while outbufbit <> 4 do
  191.       putoutbit(0); { FILL so that EOL's are byte aligned }
  192.     addtostream(104, color); { FAXATREE #104 = EOL }
  193.   end;
  194.   color := not color;
  195. end;
  196.  
  197. procedure cvtscanline(width : word; pcxkind : boolean);
  198. var
  199.   bit, lastbit, bufbit, bufbyte, repeatbits, totalcount : word;
  200.   color : boolean;
  201. begin
  202.   inc(lines);
  203.   color := true;
  204.   totalcount := 0;
  205.   bufbit := 1;
  206.   bufbyte := 1;
  207.   if imagebuf[bufbyte] and base2r[bufbit] > 0 then begin
  208.     lastbit := 1;
  209.     if pcxkind then
  210.       repeatbits := 1
  211.     else
  212.       repeatbits := 64;
  213.   end else begin
  214.     lastbit := 0;
  215.     if pcxkind then
  216.       addtostream(0, true)
  217.     else
  218.       countmh(63, totalcount, color, false); { margin four spaces }
  219.     color := false;
  220.     repeatbits := 1;
  221.   end;
  222.   repeat
  223.     inc(bufbit);
  224.     if bufbit > 8 then begin
  225.       bufbit := 1;
  226.       inc(bufbyte);
  227.     end;
  228.     if bufbyte > width then begin
  229.       countmh(repeatbits, totalcount, color, true);
  230.       exit;
  231.     end;
  232.     if (imagebuf[bufbyte] and base2r[bufbit]) > 0 then
  233.       bit := 1
  234.     else
  235.       bit := 0;
  236.     if bit = lastbit then
  237.       inc(repeatbits)
  238.     else begin
  239.       countmh(repeatbits, totalcount, color, false);
  240.       repeatbits := 1;
  241.       lastbit := bit;
  242.     end;
  243.   until(false);
  244. end;
  245.  
  246. procedure processtextline;
  247. var
  248.   i, j, ki, kj : byte;
  249. begin
  250.   if tlines >= 66 then begin
  251.     tlines := 0;
  252.     makeendofpage(false);
  253.     insertlines(8);
  254.   end;
  255.   inc(tlines);
  256.   write('{p', zfax.pgcount+1, ', line ', tlines, '} ', #13);
  257.   inc(slen);
  258.   sarray[slen] := 32;
  259.   ki := 0;
  260.   for i := 0 to 15 do begin
  261.     kj := 1;
  262.     for j := 1 to slen do begin
  263.       imagebuf[kj] := fontset^[fontptr[sarray[j]]+ki+1];
  264.       imagebuf[kj+1] := fontset^[fontptr[sarray[j]]+ki];
  265.       inc(kj, 2);
  266.     end;
  267.     cvtscanline(slen+slen, false);
  268.     inc(ki, 2);
  269.   end;
  270.   slen := 0;
  271. end;
  272.  
  273. begin
  274.   writeln('MAKEFAX 1.20, BGFAX PCX/ASCII to FAX converter utility.');
  275.   writeln('Copyright (C) 1994 B.J. Guillot.  All Rights Reserved.');
  276.   if paramcount < 1 then
  277.     fatal('no file specified on command line');
  278.   writeln;
  279.   fn := paramstr(1);
  280.   write('Memory [', memavail div 1024, 'K]  File ['+fn+']  ');
  281.   fopen := fn;
  282.   assign(pcxfile, fopen);
  283.   {$i-}
  284.     reset(pcxfile, 1);
  285.     io := ioresult;
  286.     if io > 0 then begin
  287.       writeln('I/O Error [', io, ']');
  288.       fatal('cannot open ['+fopen+']');
  289.     end;
  290.   {$i+}
  291.   assign(outfile, 'OUTPUT.FAX');
  292.   rewrite(outfile, 1);
  293.   fillchar(zfax, sizeof(zfax), #0);
  294.   zfax.header := 'ZyXEL';
  295.   zfax.offset := 0;
  296.   zfax.version := 2;
  297.   zfax.reserved := 0;
  298.   zfax.pgwidth := 1728;
  299.   zfax.pgcount := 0;
  300.   zfax.coding := 0; { 1d-low res }
  301.   move(zfax, outbuf, sizeof(zfax));
  302.   outbuf[sizeof(zfax)+1] := 0;
  303.   outbuf[sizeof(zfax)+2] := 128; { dummy EOL to start fax image }
  304.   blockwrite(outfile, outbuf, sizeof(zfax)+2, io);
  305.   blockread(pcxfile, pcxbuf, sizeof(pcxrec), bytesread);
  306.   move(pcxbuf, pcx, sizeof(pcxrec));
  307.   lines := 0;
  308.   p := 0;
  309.   bytesread := 0;
  310.   pcxbufp := 1;
  311.   endofpage := false;
  312.   outbufbit := 0;
  313.   outbufbyte := 1;
  314.   fillchar(outbuf, sizeof(outbuf), #0);
  315.   fillchar(imagebuf, sizeof(imagebuf), #0);
  316.   if pcx.zsoft = 10 then begin { PCX signature }
  317.     tlines := 65535; { non-text mode }
  318.     if (pcx.bitpix<>1) or (pcx.planes<>1) then
  319.       fatal('Only 2-color PCX files can be converted');
  320.     writeln('Size [', filesize(pcxfile) div 1024, 'K]');
  321.     writeln('Bits Wide [', pcx.dimens[3]+1,
  322.       ']  Scan Lines [', pcx.dimens[4]+1, ']');
  323.     if pcx.dimens[3] > 1727 then
  324.       fatal('Page width must be 1728 bits or shorter');
  325.     repeat
  326.       v := readbyte;
  327.       if (v and 192) = 192 then begin { repition }
  328.         r := v xor 192;
  329.         v := r; { reset v as the real count }
  330.         j := readbyte; { read the actual count }
  331.         if r + p > pcx.byteline then begin
  332.           r := pcx.byteline-p;
  333.           fillchar(imagebuf[p+1], r, j);
  334.           cvtscanline(pcx.byteline, true);
  335.           r := v - r;
  336.           fillchar(imagebuf, r, j);
  337.           p := r;
  338.         end else begin
  339.           fillchar(imagebuf[p+1], r, j);
  340.           inc(p, v);
  341.         end;
  342.       end else begin
  343.         inc(p);
  344.         imagebuf[p] := v;
  345.       end;
  346.       if p = pcx.byteline then begin
  347.         cvtscanline(pcx.byteline, true);
  348.         fillchar(imagebuf, sizeof(imagebuf), #0);
  349.         p := 0;
  350.       end;
  351.     until(false);
  352.   end else begin { ASCII file }
  353.     tlines := 0;
  354.     for v := 0 to 255 do
  355.       fontptr[v] := v*32;
  356.     fopen := 'BGFAX.FNT';
  357.     assign(fontfile, fopen);
  358.     {$i-}
  359.       reset(fontfile, 1);
  360.       io := ioresult;
  361.       if io > 0 then begin
  362.         writeln('I/O error [', io, ']');
  363.         fatal('cannot open font file ['+fopen+']');
  364.       end;
  365.     {$i+}
  366.     new(fontset);
  367.     blockread(fontfile, fontset^, filesize(fontfile), j);
  368.     close(fontfile);
  369.     close(pcxfile);
  370.     reset(pcxfile, 1);
  371.     slen := 0;
  372.     pcx.byteline := 216;
  373.     writeln;
  374.     insertlines(8);
  375.     repeat
  376.       v := readbyte;
  377.       if (v = 13) then begin
  378.         v := readbyte; { a linefeed }
  379.         processtextline;
  380.       end else if slen > 99 then begin {allows 100 char width}
  381.         inc(slen);
  382.         sarray[slen] := v;
  383.         processtextline;
  384.       end else begin
  385.         inc(slen);
  386.         sarray[slen] := v;
  387.       end;
  388.     until(false);
  389.   end;
  390. end.
  391.